home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / PROGRAM / MODEM.ARJ / MODEM.PAS < prev    next >
Pascal/Delphi Source File  |  1991-10-02  |  13KB  |  501 lines
  1. {                   Copyright Borland International
  2.  This program can be freely distributed without any royalties to Borland.
  3.  No technical support is provided by Borland for this program.
  4.  This example is posted on CompuServe as a learning tool.}
  5.  
  6. {$R Modem}
  7. uses WinTypes, WinProcs, WObjects, Strings;
  8. type
  9.   TEditLine = array[0..50] of Char;
  10. const
  11.   idEdit      = 100;
  12.   idDial      = 201;
  13.   idDialStart = 101;
  14.   idPhoneNum  = 102;
  15.   idConfigure = 202;
  16.   id1200      = 101;
  17.   id2400      = 102;
  18.   id4800      = 103;
  19.   id9600      = 104;
  20.   idOdd       = 105;
  21.   idEven      = 106;
  22.   idNone      = 107;
  23.   idComm1     = 108;
  24.   idComm2     = 109;
  25.   id1Stop     = 110;
  26.   id2Stop     = 111;
  27.   id7Data     = 112;
  28.   id8Data     = 113;
  29.  
  30.   LineWidth   = 80;  { Width of each line displayed.                 }
  31.   LineHeight  = 60;  { Number of line that are held in memory.       }
  32.  
  33.   { The configuration string bellow is used to configure the modem.  }
  34.   { It is set for communication port 2, 2400 baud, No parity, 8 data }
  35.   { bits, 1 stop bit.                                                }
  36.  
  37.   Comm  : Char = '2';
  38.   Baud  : Word = 24;
  39.   Parity: Char = 'n';
  40.   Stop  : Char = '1';
  41.   Data  : Char = '8';
  42.  
  43.   DialStart: TEditLine = 'ATDT';
  44.   PhoneNumber: TEditLine = '';
  45.  
  46.  
  47. type
  48.   TApp = object(TApplication)
  49.     procedure Idle; virtual;
  50.     procedure InitMainWindow; virtual;
  51.     procedure MessageLoop; virtual;
  52.   end;
  53.  
  54.   PBuffer = ^TBuffer;
  55.   TBuffer = object(TCollection)
  56.     Pos: Integer;
  57.     constructor Init(AParent: PWindow);
  58.     procedure FreeItem(Item: Pointer); virtual;
  59.     function PutChar(C: Char): Boolean;
  60.   end;
  61.  
  62.   PCommWindow = ^TCommWindow;
  63.   TCommWindow = object(TWindow)
  64.     Cid: Integer;
  65.     Buffer: PBuffer;
  66.     FontRec: TLogFont;
  67.     CharHeight: Integer;
  68.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  69.     destructor Done; virtual;
  70.     procedure Configure(var Message: TMessage);
  71.       virtual cm_First + idConfigure;
  72.     procedure Dial(var Message: TMessage);
  73.       virtual cm_First + idDial;
  74.     procedure Error(E: Integer; C: PChar);
  75.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  76.     procedure ReadChar; virtual;
  77.     procedure SetConfigure;
  78.     procedure SetHeight;
  79.     procedure SetUpWindow; virtual;
  80.     procedure wmChar(var Message: TMessage);
  81.       virtual wm_Char;
  82.     procedure wmSize(var Message: TMessage);
  83.       virtual wm_Size;
  84.     procedure WriteChar;
  85.   end;
  86.  
  87. { TBuffer }
  88. { The Buffer is use to hold each line that is displayed in the main    }
  89. { window.  The constance LineHeight determines the number of line that }
  90. { are stored.  The Buffer is prefilled with the LineHeight worth of    }
  91. { lines.                                                               }
  92. constructor TBuffer.Init(AParent: PWindow);
  93. var
  94.   P: PChar;
  95.   I: Integer;
  96. begin
  97.   TCollection.Init(LineHeight + 1, 10);
  98.   GetMem(P, LineWidth + 1);
  99.   P[0] := #0;
  100.   Pos := 0;
  101.   Insert(P);
  102.   for I := 1 to LineHeight do
  103.   begin
  104.     GetMem(P, LineWidth + 1);
  105.     P[0] := #0;
  106.     Insert(P);
  107.   end;
  108. end;
  109.  
  110. procedure TBuffer.FreeItem(Item: Pointer);
  111. begin
  112.   FreeMem(Item, LineWidth + 1);
  113. end;
  114.  
  115. { This procedure is process all incomming in formation from the com  }
  116. { port.  This procedure is called by TCommWindow.ReadChar.           }
  117.  
  118. function TBuffer.PutChar(C: Char): Boolean;
  119. var
  120.   Width: Integer;
  121.   P: PChar;
  122. begin
  123.   PutChar := False;
  124.   Case C of
  125.     #13: Pos := 0;                          { if a Carriage Return.  }
  126.     #10:                                    { if a Line Feed.        }
  127.       begin
  128.         GetMem(P, LineWidth + 1);
  129.         FillChar(P^, LineWidth + 1, ' ');
  130.         P[Pos] := #0;
  131.         Insert(P);
  132.       end;
  133.     #8:
  134.       if Pos > 0 then                       { if a Delete.           }
  135.       begin
  136.         Dec(Pos);
  137.         P := At(Count - 1);
  138.         P[Pos] := ' ';
  139.       end;
  140.    #32..#128:                               { else handle all other  }
  141.     begin                                   { displayable characters.}
  142.       P := At(Count - 1);
  143.       Width := StrLen(P);
  144.       if Width > LineWidth then             { if line is to wide     }
  145.       begin                                 { create a new line.     }
  146.         Pos := 1;
  147.         GetMem(P, LineWidth + 1);
  148.         P[0] := C;
  149.         P[1] := #0;
  150.         Insert(P);
  151.       end
  152.       else                                   { else add character    }
  153.       begin                                  { to current line.      }
  154.         P[Pos] := C;
  155.         Inc(Pos);
  156.         P[Pos] := #0;
  157.       end;
  158.     end;
  159.   end;
  160.   if Count > LineHeight then                 { if more to many lines }
  161.   begin                                      { have been added delete}
  162.     AtFree(0);                               { current line and let  }
  163.     PutChar := True;                         { the call procedure    }
  164.   end;                                       { know to scroll up.    }
  165. end;
  166.  
  167. { TCommWindow }
  168. { The CommWindow displays the incoming and out goinging text.  There  }
  169. { should be mention that the text type by the use is displayed by     }
  170. { being echo back to the ReadChar procedure.  So there is no need for }
  171. { wmChar to write a character to the screen.                          }
  172. constructor TCommWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  173. begin
  174.   TWindow.Init(AParent, ATitle);
  175.   Attr.Style := Attr.Style or ws_VScroll;
  176.   Attr.Menu := LoadMenu(HInstance, 'Menu_1');
  177.   Scroller := New(PScroller, Init(@Self, 1, 1, 100, 100));
  178.   Buffer := New(PBuffer, Init(@Self));
  179. end;
  180.  
  181. { Close the Comm port and deallocate the Buffer.                      }
  182. destructor TCommWindow.Done;
  183. begin
  184.   Error(CloseComm(Cid), 'Close');
  185.   Dispose(Buffer, Done);
  186.   TWindow.Done;
  187. end;
  188.  
  189. procedure TCommWindow.Configure(var Message: TMessage);
  190. var
  191.   Trans: record
  192.     R1200,
  193.     R2400,
  194.     R4800,
  195.     R9600,
  196.     ROdd,
  197.     REven,
  198.     RNone,
  199.     RComm1,
  200.     RComm2,
  201.     R1Stop,
  202.     R2Stop,
  203.     R7Data,
  204.     R8Data: Word;
  205.   end;
  206.   D: TDialog;
  207.   P: PWindowsObject;
  208.   I: Integer;
  209. begin
  210.   D.Init(@Self, 'Configure');
  211.   For I := id1200 to id8Data do
  212.     P := New(PRadioButton, InitResource(@D, I));
  213.   With Trans do
  214.   begin
  215.     R1200 := Byte(Baud = 12);
  216.     R2400 := Byte(Baud = 24);
  217.     R4800 := Byte(Baud = 48);
  218.     R9600 := Byte(Baud = 96);
  219.  
  220.     ROdd  := Byte(Parity = 'o');
  221.     REven := Byte(Parity = 'e');
  222.     RNone := Byte(Parity = 'n');
  223.  
  224.     RComm1 := Byte(Comm = '1');
  225.     RComm2 := Byte(Comm = '2');
  226.  
  227.     R1Stop := Byte(Stop = '1');
  228.     R2Stop := Byte(Stop = '2');
  229.  
  230.     R7Data := Byte(Data = '7');
  231.     R8Data := Byte(Data = '8');
  232.   end;
  233.   D.TransferBuffer := @Trans;
  234.   if D.Execute = id_Ok then
  235.   begin
  236.     with Trans do
  237.     begin
  238.       Baud := (R1200 * 12) + (R2400 * 24) + (R4800 * 48) + (R9600 * 96);
  239.       if ROdd = bf_Checked then
  240.         Parity := 'o';
  241.       if REven = bf_Checked then
  242.         Parity := 'e';
  243.       if RNone = bf_Checked then
  244.         Parity := 'n';
  245.       if R1Stop = bf_Checked then
  246.         Stop := '1'
  247.       else
  248.         Stop := '2';
  249.       if RComm1 = bf_Checked then
  250.         Comm := '1'
  251.       else
  252.         Comm := '2';
  253.       if R7Data = bf_Checked then
  254.         Data := '7'
  255.       else
  256.         Data := '8';
  257.       SetConfigure;
  258.     end;
  259.   end;
  260.   D.Done;
  261. end;
  262.  
  263.  
  264. procedure TCommWindow.Dial(var Message: TMessage);
  265. var
  266.   Trans: record
  267.     Start: TEditLine;
  268.     Phone: TEditLine;
  269.   end;
  270.   D: TDialog;
  271.   P: PWindowsObject;
  272. begin
  273.   D.Init(@Self, 'Dial');
  274.   P := New(PEdit, InitResource(@D, idDialStart, SizeOf(TEditLine)));
  275.   P := New(PEdit, InitResource(@D, idPhoneNum, SizeOf(TEditLine)));
  276.   StrCopy(Trans.Start, DialStart);
  277.   StrCopy(Trans.Phone, PhoneNumber);
  278.   D.TransferBuffer := @Trans;
  279.   if D.Execute = id_Ok then
  280.   begin
  281.     StrCopy(DialStart, Trans.Start);
  282.     StrCopy(PhoneNumber, Trans.Phone);
  283.     StrCat(PhoneNumber, #13);
  284.     StrCat(PhoneNumber, #10);
  285.     if CID <> 0 then
  286.     begin
  287.       Error(WriteComm(CId, DialStart, StrLen(DialStart)), 'Writing');
  288.       Error(WriteComm(CId, PhoneNumber, StrLen(PhoneNumber)), 'Writing');
  289.     end;
  290.     PhoneNumber[StrLen(PhoneNumber) - 2] := #0;
  291.   end;
  292.   D.Done;
  293. end;
  294.  
  295.  
  296. { Checks for comm errors and writes any errors.                       }
  297. procedure TCommWindow.Error(E: Integer; C: PChar);
  298. var
  299.   S: array[0..100] of Char;
  300. begin
  301.   if E >= 0 then exit;
  302.   Str(E, S);
  303.   MessageBox(GetFocus, S, C, mb_Ok);
  304. end;
  305.  
  306. { Redraw all the lines in the buffer by using ForEach.                }
  307. procedure TCommWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  308. var
  309.   I: Integer;
  310.   Font: HFont;
  311.  
  312.   procedure WriteOut(Item: PChar); far;
  313.   begin
  314.     TextOut(PaintDC, 0, CharHeight * I, Item, StrLen(Item));
  315.     inc(I);
  316.   end;
  317.  
  318. begin
  319.   I := 0;
  320.   Font := SelectObject(PaintDC, CreateFontIndirect(FontRec));
  321.   Buffer^.ForEach(@WriteOut);
  322.   DeleteObject(SelectObject(PaintDC, Font));
  323. end;
  324.  
  325. { Read a charecter from the comm port, if there is no error then call }
  326. { Buffer^.PutChar to add it to the buffer and write it to the screen. }
  327. procedure TCommWindow.ReadChar;
  328. var
  329.   Stat: TComStat;
  330.   I, Size: Integer;
  331.   C: Char;
  332. begin
  333.   GetCommError(CID, Stat);
  334.   for I := 1 to Stat.cbInQue do
  335.   begin
  336.     Size := ReadComm(CId, @C, 1);
  337.     Error(Size, 'Read Comm');
  338.     if C <> #0 then
  339.     begin
  340.       if Buffer^.PutChar(C) then
  341.       begin
  342.         ScrollWindow(HWindow, 0, -CharHeight, Nil, Nil);
  343.         UpDateWindow(HWindow);
  344.       end;
  345.       WriteChar;
  346.     end;
  347.   end;
  348. end;
  349.  
  350. procedure TCommWindow.SetConfigure;
  351. var
  352.   Config: array[0..20] of Char;
  353.   S: array[0..5] of Char;
  354.   DCB: TDCB;
  355. begin
  356.   StrCopy(Config, 'com?:??,?,?,?');
  357.   Config[3] := Comm;
  358.   Config[8] := Parity;
  359.   Config[10] := Data;
  360.   Config[12] := Stop;
  361.   Str(Baud, S);
  362.   Config[5] := S[0];
  363.   Config[6] := S[1];
  364.   BuildCommDCB(Config, DCB);
  365.   DCB.ID := CID;
  366.   Error(SetCommState(DCB), 'Set Comm State');
  367. end;
  368.  
  369. procedure TCommWindow.SetUpWindow;
  370. var
  371.   DCB: TDCB;
  372. begin
  373.   TWindow.SetUpWindow;
  374.   SetHeight;
  375.  
  376. { Open for Comm2 2400 Baud, No Parity, 8 Data Bits, 1 Stop Bit }
  377.  
  378.   Cid := OpenComm('COM2', 1024, 1024);
  379.   Error(Cid, 'Open');
  380.   SetConfigure;
  381.   WriteComm(Cid, 'ATZ'#13#10, 5);  { Send a reset to Modem. }
  382. end;
  383.  
  384. { Call back function used only in to get record structure for fixed   }
  385. { width font.                                                         }
  386. function GetFont(LogFont: PLogFont; TM: PTextMetric; FontType: Word;
  387.   P: PCommWindow): Integer; export;
  388. begin
  389.   if P^.CharHeight = 0 then
  390.   begin
  391.     P^.FontRec := LogFont^;
  392.     P^.CharHeight := P^.FontRec.lfHeight;
  393.   end;
  394. end;
  395.  
  396. { Get the a fix width font to use in the TCommWindow.  Use EnumFonts  }
  397. { to save work of create the FontRec by hand.                         }
  398. { The TScroller of the main window is also updated know that the font }
  399. { height is known.                                                    }
  400. procedure TCommWindow.SetHeight;
  401. var
  402.   DC: HDC;
  403.   ProcInst: Pointer;
  404. begin
  405.   DC := GetDC(HWindow);
  406.   CharHeight := 0;
  407.   ProcInst := MakeProcInstance(@GetFont, HInstance);
  408.   EnumFonts(DC, 'Courier', ProcInst, @Self);
  409.   FreeProcInstance(ProcInst);
  410.   ReleaseDC(HWindow, DC);
  411.  
  412.   Scroller^.SetUnits(CharHeight, CharHeight);
  413.   Scroller^.SetRange(LineWidth, LineHeight);
  414.   Scroller^.ScrollTo(0, LineHeight);
  415. end;
  416.  
  417.  
  418. { Write the character from the pressed key to the Comuniction Port.   }
  419. procedure TCommWindow.wmChar(var Message: TMessage);
  420. begin
  421.   if CID <> 0 then
  422.     Error(WriteComm(CId, @Message.wParam, 1), 'Writing');
  423. end;
  424.  
  425. procedure TCommWindow.wmSize(var Message: TMessage);
  426. begin
  427.   TWindow.wmSize(Message);
  428.   Scroller^.SetRange(LineWidth, LineHeight - (Message.lParamhi div CharHeight));
  429. end;
  430.  
  431. procedure TCommWindow.WriteChar;
  432. var
  433.   DC: HDC;
  434.   Font: HFont;
  435.   S: PChar;
  436.   APos: Integer;
  437. begin
  438.   APos := Buffer^.Count - 1;
  439.   S := Buffer^.AT(APos);
  440.   APos := (APos - Scroller^.YPos) * CharHeight;
  441.   if APos < 0 then exit;
  442.   if Hwindow <> 0 then
  443.   begin
  444.     DC := GetDC(HWindow);
  445.     Font := SelectObject(DC, CreateFontIndirect(FontRec));
  446.     TextOut(DC, 0, APos, S, StrLen(S));
  447.     DeleteObject(SelectObject(DC, Font));
  448.     ReleaseDC(HWindow, DC);
  449.   end;
  450. end;
  451.  
  452. { TApp }
  453. procedure TApp.Idle;
  454. var
  455.   Stat: TComStat;
  456.   I, Size: Integer;
  457.   C: Char;
  458. begin
  459.   if MainWindow <> Nil then
  460.     if MainWindow^.HWindow <> 0 then
  461.       PCommWindow(MainWindow)^.ReadChar;
  462. end;
  463.  
  464. procedure TApp.InitMainWindow;
  465. begin
  466.   MainWindow := New(PCommWindow, Init(Nil, 'Comm Test'));
  467. end;
  468.  
  469. { Add Idle loop to main message loop.                                 }
  470. procedure TApp.MessageLoop;
  471. var
  472.   Message: TMsg;
  473. begin
  474.   while True do
  475.   begin
  476.     if PeekMessage(Message, 0, 0, 0, pm_Remove) then
  477.     begin
  478.       if Message.Message = wm_Quit then
  479.       begin
  480.         Status := Message.WParam;
  481.         Exit;
  482.       end;
  483.       if not ProcessAppMsg(Message) then
  484.       begin
  485.         TranslateMessage(Message);
  486.         DispatchMessage(Message);
  487.       end;
  488.     end
  489.     else
  490.       Idle;
  491.   end;
  492. end;
  493.  
  494. var
  495.   App: TApp;
  496. begin
  497.   App.Init('Comm');
  498.   App.Run;
  499.   App.Done;
  500. end.
  501.